home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue25 / mfboid1s / MFBOID1S.ZIP / uBoids.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-02-18  |  10.6 KB  |  367 lines
  1. unit uBoids;
  2.  
  3. interface
  4.  
  5. uses
  6.     Graphics, Classes,uTMovable;
  7.  
  8. const
  9.   RecommendedSpeed = 0.45;
  10.   LowestSpeedAllowed = 0.5;
  11.  
  12. type
  13.     TObstacle = class;
  14.  
  15.   TBoid = class(TMovable)
  16.     bSmashed                                : boolean;
  17.     iTeamNumber                            : integer;
  18.  
  19.     DeltaDirToClosest             : real;
  20.     AbsDirToClosest                    : real;
  21.     SQRDist                                    : real;
  22.     sDx,sDy                     : real;
  23.     AbsDirToAvg                            : real;
  24.     AvgSpeed                                : real;
  25.     AvgDir                                    : real;
  26.  
  27.       // Unique to every boid if they are to be extended,
  28.     // but usually the same.
  29.     MaxSpeedChange     : real;
  30.       SensorDistance     : real;
  31.  
  32.       OptimalDistance : real;
  33.     StayInCenter        : real;
  34.       TooClose                 : real;
  35.       ReallyClose         : real;
  36.       MaxTurnSpeed         : real;
  37.  
  38.     procedure AvoidObstacle(Canvas : TCanvas;ClosestObstacle : TObstacle);
  39.     function AvoidBoid(ClosestBoid : TBoid) : boolean;
  40.     procedure StayCentered;
  41.     function PrepareToMove(ClosestBoids : TList; ClosestObstacle : TMovable; Canvas : TCanvas) : boolean ; override;
  42.  
  43.     procedure IncreaseSpeed(delta : real);override;
  44.     procedure DecreaseSpeed(delta : real);override;
  45.  
  46.     procedure TurnLeft(delta : real);override;
  47.     procedure TurnRight(delta : real);override;
  48.   private
  49.       TurnFraction                : real;
  50.   end;
  51.  
  52.   TObstacle = class(TMovable)
  53.       Size                     : integer;
  54.     AvoidSphere        : real;
  55.     procedure Draw(Canvas : TCanvas);override;
  56.     function PrepareToMove(ClosestBoids : TList;ClosestObstacle : TMovable; Canvas : TCanvas) : boolean;override;
  57.    // procedure Move(Canvas : TCanvas);override;
  58.     constructor Create(inX, inY,inSize : Integer; inColor : TColor; Canvas : TCanvas);
  59.     end;
  60.  
  61. implementation
  62.  
  63. //******************************************************************************
  64. procedure TBoid.TurnLeft(delta : real);
  65. begin
  66.   Dir := Dir - Min(MaxTurnSpeed,abs(delta));
  67. end;
  68.  
  69. //******************************************************************************
  70. procedure TBoid.TurnRight(delta : real);
  71. begin
  72.   Dir := Dir + Min(MaxTurnSpeed,abs(delta));
  73. end;
  74.  
  75. //******************************************************************************
  76. procedure TBoid.IncreaseSpeed(delta : real);
  77. begin
  78.   // Increase is slower than decrease
  79.   Speed := Speed + Min(MaxSpeedChange,delta) + Deviation(0.05);
  80.   if Speed > 1 then speed := 1;
  81.   if Color <> clGreen then
  82.       Color := clBlue;
  83.   bSpeedHasChanged := true;
  84. end;
  85.  
  86. //******************************************************************************
  87. procedure TBoid.DecreaseSpeed(delta : real);
  88. begin
  89.   // Increase is slower than decrease
  90.   Speed := Speed - Min(MaxSpeedChange,delta) + Deviation(0.05);
  91.   if Speed < LowestSpeedAllowed then Speed := LowestSpeedAllowed;
  92.   if Color <> clGreen then
  93.       Color := clRed;
  94.   bSpeedHasChanged := true;
  95. end;
  96.  
  97. //******************************************************************************
  98. procedure TBoid.AvoidObstacle(Canvas : TCanvas;ClosestObstacle : TObstacle);
  99. var
  100.     ODistSQR                        : real;
  101.   ODir                                : real;
  102.   ClosestDistance            : real;
  103.   AvoidObstacleDistSQR : real;
  104.   fPanicLevel                    : real;
  105.   fTurnDir                        : real;
  106. begin
  107.  if (ClosestObstacle <> nil) then
  108.   begin
  109.        AvoidObstacleDistSQR := ClosestObstacle.AvoidSphere;
  110.  
  111.     ODistSQR := sqr(x-ClosestObstacle.X) + sqr(y-ClosestObstacle.y);
  112.  
  113.         if (ODistSQR < AvoidObstacleDistSQR) then
  114.     begin
  115.           ODir := ConfineDirection(Dir-MyArcTan(ClosestObstacle.X-x,ClosestObstacle.y-y));
  116.  
  117.             ClosestDistance := abs(sin(ODir) * Sqrt(ODistSQR));
  118.  
  119.             if (abs(ODir) < pi/2) and (ClosestDistance < ClosestObstacle.Size) then
  120.             begin
  121.         //fPanicLevel := 1-ODistSQR/AvoidObstacleDistSQR;
  122.         fPanicLevel := max(1-ODistSQR/AvoidObstacleDistSQR,
  123.         1 - ClosestDistance/(ClosestObstacle.Size/2));
  124.  
  125.       {  Canvas.Pen.Color := clWhite;
  126.           Canvas.MoveTo(trunc(x),trunc(y));
  127.                 Canvas.LineTo(trunc(x + cos(Dir-ODir)*ClosestDistance),
  128.                                   trunc(y + sin(Dir-ODir)*ClosestDistance));
  129.  
  130.                 Canvas.MoveTo(trunc(x),trunc(y));
  131.            Canvas.LineTo(trunc(x + cos(Dir)*ClosestDistance),
  132.                                     trunc(y + sin(Dir)*ClosestDistance));
  133.  
  134.         // }
  135.  
  136.                 fTurnDir :=(pi-abs(ODir))*fPanicLevel;
  137.  
  138.         if ODir > 0 then
  139.           TurnRight(fTurnDir)
  140.         else
  141.           TurnLeft(fTurnDir);
  142.  
  143.         Color := clGreen;
  144.  
  145. //        TurnFraction := 1 - fPanicLevel;
  146.         TurnFraction := 0.1;
  147.  
  148.         if fPanicLevel > 0.4 then
  149.         begin
  150.             DecreaseSpeed(fPanicLevel/10);
  151.             TurnFraction := 0.1;
  152.         end;
  153.  
  154.                  if fPanicLevel > 0.6 then
  155.           TurnFraction := 0.0;
  156.       end;
  157.     end;
  158.   end; //}
  159. end;
  160.  
  161. function TBoid.AvoidBoid(ClosestBoid : TBoid) : boolean;
  162. begin
  163.     AvoidBoid := false;
  164.   
  165.   if (ClosestBoid.DistanceSquared < sqr(TooClose)) then
  166.   begin
  167.     // Don't fly directly behind someone!
  168.     //if abs(DeltaDir) < 0.02 then DeltaDir := 0.07;
  169.     if abs(DeltaDirToClosest) < 0.02 then DeltaDirToClosest := 0.1;
  170.  
  171.       // Allow boids going the same direction to be closer
  172.     if (DeltaDirToClosest < 0.09) and
  173.        (ClosestBoid.DistanceSquared > sqr(ReallyClose)) then
  174.         DeltaDirToClosest := 0;
  175.  
  176.     if DeltaDirToClosest <> 0 then
  177.     begin
  178.         bSmashed := true;
  179.       AvoidBoid := true;
  180.  
  181.       if AbsDirToClosest < 0 then
  182.           TurnRight(DeltaDirToClosest{*0.15}*TurnFraction)
  183.         else
  184.           TurnLeft(DeltaDirToClosest{*0.15}*TurnFraction);
  185.  
  186.       // Adjust speed!
  187.       if Within(AbsDirToClosest,-Pi/2,0) and
  188.          Within(DeltaDirToClosest,0,Pi) then  // Beta2
  189.         DecreaseSpeed(abs(ClosestBoid.Speed-Speed)+0.09);
  190.  
  191.       if Within(AbsDirToClosest,0,Pi/2) and
  192.          Within(DeltaDirToClosest,-Pi,0) then
  193.         DecreaseSpeed(abs(ClosestBoid.Speed-Speed)+0.09);
  194.  
  195.       // Overrules the next rule
  196.       if (ClosestBoid.DistanceSquared < sqr(ReallyClose)) then
  197.           TurnFraction := 0.01*TurnFraction;
  198.     end;
  199.   end;
  200.   //}
  201. end;
  202.  
  203. procedure TBoid.StayCentered;
  204. var
  205.   NewAvgDir                        : real;
  206.   LocalTurnFraction        : real;
  207. begin
  208.   if SqrDist > sqr(OptimalDistance-StayInCenter) then
  209.   begin
  210.     //3.Cohesion: steer to move toward the average position of local flockmates. / Craig Reynolds
  211.     // We're too far off, stear not only in the same direciton,
  212.     // but towards the center of gravity!
  213.     NewAvgDir := MyArcTan(sDx-x,sDy-y);
  214.  
  215.     // Break if you're in front of the crowd,
  216.     // speed up if you're behind it.
  217.     if Abs(ConfineDirection(Dir-AbsDirToAvg)) < pi/2 then
  218.       IncreaseSpeed(abs(AvgSpeed-Speed)+0.02)
  219.     else
  220.       DecreaseSpeed(abs(AvgSpeed-Speed)+0.02);
  221.   end else NewAvgDir := AvgDir;
  222.  
  223.   if Dir < NewAvgDir then
  224.     TurnRight(Abs(Dir - NewAvgDir)*TurnFraction)
  225.   else
  226.     TurnLeft(Abs(Dir - NewAvgDir)*TurnFraction);
  227.   //}       *)
  228. end;
  229.  
  230. //******************************************************************************
  231. function TBoid.PrepareToMove(ClosestBoids : TList; ClosestObstacle : TMovable; Canvas : TCanvas) : boolean;
  232. var
  233.   i                   : integer;
  234.   ClosestBoid         : TBoid;
  235.   RelativeDirection   : real;
  236.   dx,dy               : real;
  237.  
  238.   bNeighboursFound    : boolean;
  239.  
  240.   RelDirToAvg            : real;
  241.   iTeamCount                    : integer;
  242.   LastMoveXSum                : real;
  243.   LastMoveYSum                : real;
  244.   TestBoid                        : TBoid;
  245. begin
  246.   // First, collect data
  247.   Color := clWhite;
  248.   bSpeedHasChanged := false;
  249.   bSmashed := false;
  250.   iTeamCount := 0;
  251.  
  252.   PrepareToMove := false;
  253.  
  254.   sDx := 0;
  255.   sDy := 0;
  256.   AvgSpeed := 0;
  257.   AvgDir := 0;
  258.  
  259.   bNeighboursFound := ClosestBoids.Count <> 0;
  260.  
  261.   if bNeighboursFound then
  262.     ClosestBoid := ClosestBoids[0]
  263.   else
  264.     ClosestBoid := nil;
  265.  
  266.   for i := 0 to ClosestBoids.Count - 1 do
  267.   begin
  268.       TestBoid := ClosestBoids[i];
  269.       AvgSpeed := AvgSpeed + TestBoid.Speed;
  270.       AvgDir := AvgDir + TestBoid.Dir;
  271.     sDx := sDx + TestBoid.X;
  272.     sDy := sDy + TestBoid.Y;
  273.     LastMoveXSum := LastMoveXSum + TestBoid.LastMoveX;
  274.     LastMoveYSum := LastMoveYSum + TestBoid.LastMoveY;
  275.  
  276.     if TestBoid.DistanceSquared < ClosestBoid.DistanceSquared then
  277.       ClosestBoid := ClosestBoids[i];
  278.   end;
  279.  
  280.   if bNeighboursFound then
  281.   begin
  282.     AvgSpeed := AvgSpeed / ClosestBoids.Count;
  283.  
  284.     AvgDir := AvgDir / ClosestBoids.Count{ + (random(100)-50)/5000;//};
  285.         // Calculate the average heading of the surrounding flock, including
  286.     // the boid itself
  287.     {AvgDir := MyArcTan(LastMoveXSum+LastMoveX*ClosestBoids.Count/2,
  288.         LastMoveYSum+LastMoveY*ClosestBoids.Count/2);}
  289.     sDx := sDx / ClosestBoids.Count;
  290.     sDy := sDy / ClosestBoids.Count;
  291.  
  292.     dx := ClosestBoid.X-x;
  293.     dy := ClosestBoid.Y-y;
  294.  
  295.     AbsDirToClosest := MyArcTan(dx,dy);
  296.     AbsDirToAvg := MyArcTan(sDx-x,sDy-y);
  297.       DeltaDirToClosest := ConfineDirection(abs(ClosestBoid.Dir-Dir));
  298.   end
  299.   else
  300.   begin
  301.     AvgSpeed := RecommendedSpeed;
  302.     AvgDir := Dir;
  303.     AbsDirToClosest := dir;
  304.     sDx := 0;
  305.     sDy := 0;
  306.     DeltaDirToClosest := 0;
  307.   end;
  308.  
  309.   SQRDist := sqr(sDx-x)+sqr(sDy-y);
  310.   TurnFraction := 1.0;
  311.  
  312.   // Craig Reynold's three rules of flocking are;
  313.   // 1.Separation: steer to avoid crowding local flockmates.
  314.   // 2.Alignment: steer towards the average heading of local flockmates.
  315.   // 3.Cohesion: steer to move toward the average position of local flockmates.
  316.  
  317.   // Rule zero is just to spice it up!
  318.  
  319.   // * Rule zero; don't hit the obstacle!
  320.      AvoidObstacle(Canvas,TObstacle(ClosestObstacle));
  321.  
  322.   // 1.Separation: steer to avoid crowding local flockmates. / Craig Reynolds
  323.   if bNeighboursFound then
  324.         AvoidBoid(ClosestBoid);
  325.  
  326.   //2.Alignment: steer towards the average heading of local flockmates. / Craig Reynolds
  327.     // and
  328.   //3.Cohesion: steer to move toward the average position of local flockmates.
  329.   if bNeighboursFound then
  330.         StayCentered;
  331. end;
  332.  
  333. //******************************************************************************
  334. procedure TObstacle.Draw(Canvas : TCanvas);
  335. var
  336.   cX, cy : integer;
  337.   hSize     : integer;
  338. begin
  339.     if not bActive then exit;
  340.     cx := trunc(x);
  341.   cy := trunc(y);
  342.   hSize := Size div 2;
  343.   Canvas.Brush.Color := Color;
  344.   Canvas.Pen.Color := Color;
  345.   Canvas.Ellipse(Cx - hSize, Cy - hSize,Cx + hSize, Cy + hSize);
  346.   Canvas.Brush.Color := clWhite;
  347. end;
  348.  
  349. //******************************************************************************
  350. function TObstacle.PrepareToMove(ClosestBoids : TList;ClosestObstacle : TMovable; Canvas : TCanvas):boolean;
  351. begin
  352. end;
  353.  
  354. //******************************************************************************
  355. constructor TObstacle.Create(inX, inY,inSize : Integer; inColor : TColor; Canvas : TCanvas);
  356. begin
  357.     inherited Create(Canvas);
  358.     X := inX;
  359.   Y := inY;
  360.   Speed := 0;
  361.   Size := inSize;
  362.   AvoidSphere := sqr(inSize*3);
  363.   Color := inColor;
  364.   bActive := true;
  365. end;
  366. end.
  367.